;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(in-package :autoproject.util)

;; Macros

#+(or sbcl cmu)
(defmacro do-bound-slots ((name-var value-var object) &body body)
  "Evaluates BODY for each of bound slot in OBJECT.  NAME-VAR is bound
the name of the slot and VALUE-VAR to the value of that slot."
  (let ((s (gensym))
        (o (gensym)))
    `(let ((,o ,object))
       (loop :for ,s :in
          #+sbcl (sb-pcl:class-slots (class-of ,o))
          #+cmu (pcl:class-slots (pcl:class-of ,o))
          :do (let ((,name-var #+sbcl (sb-pcl:slot-definition-name ,s)
                               #+cmu (pcl:slot-definition-name ,s)))
                (when (slot-boundp ,o ,name-var)
                  (let ((,value-var (slot-value ,o ,name-var)))
                    ,@body)))))))

#+(not (or sbcl cmu))
(defmacro do-bound-slots ((name-var value-var object) &body body)
  `(error "DO-BOUND-SLOTS not present for this implementation"))


(defmacro >> (&body forms)
  "Chains FORMS together, binding IT to the result of each form."
  `(let (it)
     ,@(mapcar (lambda (form)
                 `(setf it ,form))
               forms)
     it))


;; Functions 

(defun format-list (list &key (separator ", ") 
                    (start-with "") (end-with ""))
  (format nil "~A~A~{~A~A~}~A"
          start-with
          (first list)
          (loop for i in (rest list)
                collect separator collect i)
          end-with))

(defun zip (list-1 list-2)
  (loop :for a :in list-1
        :for b :in list-2
        :collect a 
        :collect b))

(defun unzip (list)
  (loop :for (a b) :on list :by #'cddr
        :collect a :into as
        :collect b :into bs
        :finally (return (values as bs))))

(defun split-list (list offsets)
  (values (subseq list 0 offsets)
          (subseq list offsets)))

(defun keywordify (name)
  (intern name :keyword))

(defun merge-instance (instance default-instance)
  (let ((i (make-instance (class-of instance))))
    (do-bound-slots (slot val default-instance)
      (setf (slot-value i slot) val))
    (do-bound-slots (slot val instance)
      (setf (slot-value i slot) val))
    i))

(defun copy-instance (instance)
  (let ((i (make-instance (class-of instance))))
    (do-bound-slots (slot val instance)
      (setf (slot-value i slot) val))))

(defun merge-plist (plist defaults)
  (let ((s (copy-list plist)))
    (loop :for (a b) :on defaults :by #'cddr
          :do (unless (getf s a)
                (setf (getf s a) b)))
    s))

(defun listify-hash (hash &key (kind :alist))
  (declare (type (member :key :value :alist :plist) kind))

  ;; k: key, v: value
  (macrolet ((collect (&body loop-body)
               `(loop :for k :being :each :hash-key :of hash
                      :using (:hash-value v)
                      ,@loop-body)))
    (case kind
      (:alist (collect :collect (list k v)))
      (:key (collect :collect k))
      (:value (collect :collect v))
      (:plist (collect :collect k :collect v)))))

(defun partition (list predicate)
  "Splits LIST into two lists based on PREDICATE.  The elements of
LIST for which PREDICATE returns non-nil go into the first list, the
rest into the second."
  (loop :for i :in list
     :if (funcall predicate i)
     :collect i :into a
     :else
     :collect i :into b
     :finally (return (list a b))))

(defun match-up (list-1 list-2 &key
                 (test #'eql)
                 (key-1 #'identity)
                 (key-2 #'identity)
                 return-unmatched)
  "Matches up elements of LIST-1 with elements of LIST-2 based on
KEY-1 and KEY-2 respectively.

Example:

  (match-up '((FOO 1) (BAR 5) (FOO 10) (XYZ 3))
            '((BAR 1) (FOO 2) (FOO 3))
            :key-1 'first
            :key-2 'first)

  ===>  ;; first group
       ((((FOO 1) (FOO 10)) ; from LIST-1
         ((FOO 2) (FOO 3))) ; from LIST-2
        ;; second group
        (((BAR 5))          ; from LIST-1
         ((BAR 1))))        ; from LIST-2

The XYZ element is left out, since it has no counterpart in LIST-2.
"
  (let* ((unmatched-1)
         (unmatched-2)
         (matches
          (loop :with rest-1 = list-1
                :with rest-2 = list-2
		:while rest-1
		:for val-1 = (funcall key-1 (car rest-1))
                :for split-1 =
                (partition rest-1 (lambda (x)
                                    (funcall test
                                             (funcall key-1 x)
                                             val-1)))
                :for split-2 =
		(partition rest-2 (lambda (x)
                                    (funcall test
                                             (funcall key-2 x)
                                             val-1)))
                :if (and (first split-1)
                         (first split-2))
                :collect (list (first split-1)
                               (first split-2))
                :and :do (progn
                           (setf rest-1 (second split-1))
                           (setf rest-2 (second split-2)))
                :else
                :do (progn
                      (push (car rest-1) unmatched-1)
                      (setf rest-1 (cdr rest-1)))

		:finally (progn (setf unmatched-1 (append unmatched-1
                                                          rest-1))
                                (setf unmatched-2 rest-2)))))

    (if return-unmatched
        (values matches unmatched-1 unmatched-2)
        matches)))

(defun tree-preorder (tree)
  (when tree
    (destructuring-bind (system &rest deps) tree
      (let ((d (mapcar #'tree-preorder deps)))
        (append (apply #'append d) (list system))))))

(defun apply-tree-preorder (tree fn)
  (destructuring-bind (system &rest deps) tree
    (mapcar #'(lambda (x)
                (apply-tree-preorder x fn))
            deps)
    (funcall fn system)))
